home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / SHELLS / SHELLOUT / SHELLOUT.PAS
Pascal/Delphi Source File  |  1990-10-11  |  6KB  |  249 lines
  1. (*********************************************************************)
  2. (*********************************************************************)
  3. {This source code was written by:
  4.  
  5.        Harvey Arkawy
  6.        Rabbitsoft
  7.        10123 Hanna Ave.
  8.        Chatsworth, Ca. 91311
  9.        (818) 341-6104
  10.  
  11. and is released through Shareware!
  12.  
  13. The author makes no guarantee whatsoever other than it functions on
  14. his Hyundai Turbo 16.
  15.  
  16. It was compiled using Dos 3.2, 4dos 3.02 and Turbo Pascal Version 5.0
  17. and was tested using Dos 3.3 and 4.01 with 4dos 3.02.
  18.  
  19. If the procedure known as 'ShellOut' from this Pascal file or the setup
  20. routines within the test program are of any use or assistance to you,
  21. any donation of (U.S.) funds would be greatly appreciated.}
  22.  
  23. (*********************************************************************)
  24. (*********************************************************************)
  25.  
  26. Program Test;
  27. USES CRT,Dos;
  28. Var
  29.     S,
  30.     CommandCom,
  31.     OriginalDirectory  : PathStr;
  32.     ThisProgram        : NameStr;
  33.     ThisExt            : ExtStr;
  34.     OriginalDrive      : String[2];
  35.     CommandLineOptions : ComStr;
  36.     Counter            : integer;
  37.     R                  : Registers;
  38.     Ch                 : char;
  39.     Done               : Boolean;
  40.  
  41.  
  42. (**                     The procedure starts here.                      **)
  43.  
  44. PROCEDURE ShellOut(WhoAmI : PathStr);
  45. Const Null : Char = #0;
  46. Var
  47.     PSP_Seg,
  48.     NewPSP_Seg,
  49.     Environment_Seg,
  50.     NewEnvironment_Seg : word;
  51.     I,
  52.     J,
  53.     II,
  54.     JJ,
  55.     Item_Counter,
  56.     Total_Items              : Integer;
  57.     Entry                    : String[128];
  58.     Foundit                  : Boolean;
  59.     MemLocation              : Pointer;
  60.  
  61.   Function Get_PSP : Word;
  62.     Begin
  63.       R.AX := $6200;
  64.       MSDos(R);
  65.       Get_PSP := R.BX;
  66.     End;
  67.  
  68.   Procedure Release_Mem(NewEnvironment_Seg : Word);
  69.     Begin
  70.       R.AX := $4900;
  71.       R.ES := NewEnvironment_Seg;
  72.       MSDos(R);
  73.       If R.Flags and FCarry <> 0 then
  74.         Begin
  75.           Write(#7);
  76.           Writeln('Memory release failed.  Error # ',R.AX);
  77.           Halt;
  78.         End;
  79.     End;
  80.  
  81.   Function Allocate_Mem (Total_Items: Integer) : Word;
  82.     Begin
  83.       R.AX := $4800;
  84.       R.BX := ((Total_Items * 128) div 16) + 1;
  85.       MSDos(R);
  86.       If R.Flags and FCarry <> 0 then
  87.         Begin
  88.           Write(#7);
  89.           Write('Dos Call to Allocate memory failed');
  90.           Write('The largest available block is ',R.BX);
  91.           halt;
  92.         End
  93.       Else
  94.     Allocate_Mem := R.Ax;
  95.   End;
  96.  
  97.  
  98. Begin
  99.   {Determine if the 'Prompt=' is part of the environment. If not then
  100.    increase the environment quantity.}
  101.  
  102.   Foundit := False;
  103.   I := 1;
  104.   Total_Items := EnvCount;
  105.   While I <= EnvCount do
  106.     Begin
  107.       Entry := EnvStr(I);
  108.       If Pos('PROMPT=',Entry) = 1 THEN
  109.         Begin
  110.           Foundit := True;
  111.           Inc(I,EnvCount + 1);
  112.         end;
  113.       Inc(I);
  114.     End;
  115.   If Not Foundit then Inc(Total_Items);
  116.  
  117. {Get the location of the Program_Segment_Prefix and Store it in PSP_Seg.}
  118.  
  119.   PSP_Seg := Get_PSP;
  120.  
  121. {Get the pointer to the Environment's AsciiZ Strings.}
  122.  
  123.   Environment_Seg := MemW[PSP_Seg: $2C];
  124.  
  125. {Allocate Memory for the new AsciiZ strings.}
  126.  
  127.   NewEnvironment_Seg := Allocate_Mem (Total_Items);
  128.  
  129. {Set Original Environment Segment Pointer to point to the New Location.
  130.  This is required so the new PSP will have the correct location of
  131.  the new environment AsciiZ strings and therefore the child process will
  132.  use this environment information when it is executed.}
  133.  
  134.   MemW[PsP_Seg:$2C] := NewEnvironment_Seg;
  135.  
  136.  
  137. {Read in the old Environment into Entry and test for 'PROMPT='.}
  138.  
  139.   Clrscr;
  140.   I := 0;
  141.   II := 0;
  142.   Item_Counter := 0;
  143.   Repeat
  144.     J := 0;
  145.     Entry := '';
  146.     Repeat
  147.       Inc(J);
  148.       Entry[J] := Chr(Mem[Environment_Seg: I]);
  149.       Inc(I);
  150.     Until (Entry[J] = Null);
  151.     Entry[0] := Chr(J-1);
  152.     If Length(Entry) > 0 then
  153.       Begin
  154.         If Pos('PROMPT=',Entry) > 0 then
  155.           Entry := 'PROMPT=Type ''EXIT'' to return to ' + WhoAmI +
  156.               '...$_$_$P$g';
  157.  
  158. {Relocate Entry to the New Environment string location.}
  159.  
  160.         For JJ := 1 to Length(Entry) do
  161.           Begin
  162.             Mem[NewEnvironment_Seg: II ] := Ord(Entry[JJ]);
  163.             Inc(II);
  164.           End;
  165.         Mem[NewEnvironment_Seg: II ] := Ord(#0);
  166.         Inc(II);
  167.       End;
  168.   Until (Mem[Environment_Seg: I + 1] = 0);
  169.  
  170. {If no prompt in the environment, put one there.}
  171.  
  172.   If Not Foundit then
  173.     Begin
  174.       Entry := 'PROMPT=Type ''EXIT'' to return to ' + WhoAmI +
  175.          '...$_$_$P$g';
  176.       For JJ := 1 to Length(Entry) do
  177.         Begin
  178.           Mem[NewEnvironment_Seg: II ] := Ord(Entry[JJ]);
  179.           Inc(II);
  180.         End;
  181.     End;
  182.  
  183. {Clean the back end of the environment.}
  184.   For JJ := 0 to 4 do Mem[NewEnvironment_Seg: II + JJ ] := Ord(#0);
  185.  
  186. {CommandCom is equal to what Comspec equals.
  187.  Some computers don't use 'COMMAND.COM', they might use 4dos.}
  188.  
  189.   Clrscr;
  190.   SwapVectors;
  191.   Exec(CommandCom,'');
  192.   SwapVectors;
  193.  
  194.  
  195. {Restore the original PSP's environment pointer.}
  196.  
  197.   MemW[PSP_Seg:$2C] := Environment_Seg;
  198.  
  199. {Release memory (dump the new AsciiZ strings).}
  200.  
  201.   Release_Mem(NewEnvironment_Seg);
  202.  
  203. END;
  204.  
  205. (**                     The procedure ends here.                      **)
  206.  
  207.  
  208. {The test program starts here.}
  209.  
  210. Begin
  211.   FSplit(FExpand(ParamStr(0)),OriginalDirectory,ThisProgram,ThisExt);
  212.   CommandLineOptions := ParamStr(1);
  213.   OriginalDrive := copy(OriginalDirectory,1,2);
  214.   If OriginalDirectory[Length(OriginalDirectory)] = '\' then
  215.     OriginalDirectory := Copy(OriginalDirectory,1,
  216.       Length(OriginalDirectory)-1);
  217.   Counter := 0;
  218.   While Counter <= EnvCount do
  219.     Begin
  220.       S := EnvStr(Counter);
  221.       If Pos('COMSPEC=',S) = 1 THEN
  222.         Begin
  223.           Delete(S,1,8);
  224.           Counter := EnvCount + 1;
  225.         end;
  226.       Inc(Counter);
  227.     End;
  228.   CommandCom := FExpand(S);
  229.   SwapVectors;
  230.   exec(CommandCom,' /C '+ OriginalDrive);
  231.   SwapVectors;
  232.   ChDir(OriginalDirectory);
  233.   Repeat
  234.     Done := False;
  235.     Clrscr;
  236.     GotoXy(30,5);
  237.     Writeln('S] Shell to DOS');
  238.     Gotoxy(30,6);
  239.     Writeln('Q] Quit');
  240.     Gotoxy(30,8);
  241.     Write('Enter ''S'' or ''Q''');
  242.     Ch := Upcase(ReadKey);
  243.     Case Ch of
  244.       'S': ShellOut(ThisProgram);
  245.       'Q': Halt;
  246.     End;
  247.   Until Done;
  248. End.
  249.